home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / session.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  15.7 KB  |  475 lines
  1. ;;;;     Copyright (C) 1997, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17.  
  18.  
  19. (define-module (ice-9 session)
  20.   :use-module (ice-9 documentation)
  21.   :use-module (ice-9 regex)
  22.   :use-module (ice-9 rdelim)
  23.   :export (help apropos apropos-internal apropos-fold
  24.        apropos-fold-accessible apropos-fold-exported apropos-fold-all
  25.        source arity system-module))
  26.  
  27.  
  28.  
  29. ;;; Documentation
  30. ;;;
  31. (define help
  32.   (procedure->syntax
  33.     (lambda (exp env)
  34.       "(help [NAME])
  35. Prints useful information.  Try `(help)'."
  36.       (cond ((not (= (length exp) 2))
  37.              (help-usage))
  38.             ((not (provided? 'regex))
  39.              (display "`help' depends on the `regex' feature.
  40. You don't seem to have regular expressions installed.\n"))
  41.             (else
  42.              (let ((name (cadr exp))
  43.                    (not-found (lambda (type x)
  44.                                 (simple-format #t "No ~A found for ~A\n"
  45.                                                type x))))
  46.                (cond
  47.  
  48.                 ;; SYMBOL
  49.                 ((symbol? name)
  50.                  (help-doc name
  51.                            (simple-format
  52.                             #f "^~A$"
  53.                             (regexp-quote (symbol->string name)))))
  54.  
  55.                 ;; "STRING"
  56.                 ((string? name)
  57.                  (help-doc name name))
  58.  
  59.                 ;; (unquote SYMBOL)
  60.                 ((and (list? name)
  61.                       (= (length name) 2)
  62.                       (eq? (car name) 'unquote))
  63.                  (cond ((object-documentation
  64.                          (local-eval (cadr name) env))
  65.                         => write-line)
  66.                        (else (not-found 'documentation (cadr name)))))
  67.  
  68.                 ;; (quote SYMBOL)
  69.                 ((and (list? name)
  70.                       (= (length name) 2)
  71.                       (eq? (car name) 'quote)
  72.                       (symbol? (cadr name)))
  73.                  (cond ((search-documentation-files (cadr name))
  74.                         => write-line)
  75.                        (else (not-found 'documentation (cadr name)))))
  76.  
  77.                 ;; (SYM1 SYM2 ...)
  78.                 ((and (list? name)
  79.                       (and-map symbol? name)
  80.                       (not (null? name))
  81.                       (not (eq? (car name) 'quote)))
  82.                  (cond ((module-commentary name)
  83.                         => (lambda (doc)
  84.                              (display name) (write-line " commentary:")
  85.                              (write-line doc)))
  86.                        (else (not-found 'commentary name))))
  87.  
  88.                 ;; unrecognized
  89.                 (else
  90.                  (help-usage)))
  91.                *unspecified*))))))
  92.  
  93. (define (module-filename name)          ; fixme: better way? / done elsewhere?
  94.   (let* ((name (map symbol->string name))
  95.          (reverse-name (reverse name))
  96.      (leaf (car reverse-name))
  97.      (dir-hint-module-name (reverse (cdr reverse-name)))
  98.      (dir-hint (apply string-append
  99.                           (map (lambda (elt)
  100.                                  (string-append elt "/"))
  101.                                dir-hint-module-name))))
  102.     (%search-load-path (in-vicinity dir-hint leaf))))
  103.  
  104. (define (module-commentary name)
  105.   (cond ((module-filename name) => file-commentary)
  106.         (else #f)))
  107.  
  108. (define (help-doc term regexp)
  109.   (let ((entries (apropos-fold (lambda (module name object data)
  110.                  (cons (list module
  111.                          name
  112.                          (object-documentation object)
  113.                          (cond ((closure? object)
  114.                             "a procedure")
  115.                            ((procedure? object)
  116.                             "a primitive procedure")
  117.                            (else
  118.                             "an object")))
  119.                        data))
  120.                    '()
  121.                    regexp
  122.                    apropos-fold-exported))
  123.     (module car)
  124.     (name cadr)
  125.     (doc caddr)
  126.     (type cadddr))
  127.     (cond ((not (null? entries))
  128.            (let ((first? #t)
  129.                  (undocumented-entries '())
  130.                  (documented-entries '())
  131.                  (documentations '()))
  132.  
  133.              (for-each (lambda (entry)
  134.                          (let ((entry-summary (simple-format
  135.                                                #f "~S: ~S\n"
  136.                                                (module-name (module entry))
  137.                                                (name entry))))
  138.                            (if (doc entry)
  139.                                (begin
  140.                                  (set! documented-entries
  141.                                        (cons entry-summary documented-entries))
  142.                                  ;; *fixme*: Use `describe' when we have GOOPS?
  143.                                  (set! documentations
  144.                                        (cons (simple-format
  145.                                               #f "`~S' is ~A in the ~S module.\n\n~A\n"
  146.                                               (name entry)
  147.                                               (type entry)
  148.                                               (module-name (module entry))
  149.                                               (doc entry))
  150.                                              documentations)))
  151.                                (set! undocumented-entries
  152.                                      (cons entry-summary
  153.                                            undocumented-entries)))))
  154.                        entries)
  155.  
  156.              (if (and (not (null? documented-entries))
  157.                       (or (> (length documented-entries) 1)
  158.                           (not (null? undocumented-entries))))
  159.                  (begin
  160.                    (display "Documentation found for:\n")
  161.                    (for-each (lambda (entry) (display entry))
  162.                              documented-entries)
  163.                    (set! first? #f)))
  164.  
  165.              (for-each (lambda (entry)
  166.                          (if first?
  167.                              (set! first? #f)
  168.                              (newline))
  169.                          (display entry))
  170.                        documentations)
  171.  
  172.              (if (not (null? undocumented-entries))
  173.                  (begin
  174.                    (if first?
  175.                        (set! first? #f)
  176.                        (newline))
  177.                    (display "No documentation found for:\n")
  178.                    (for-each (lambda (entry) (display entry))
  179.                              undocumented-entries)))))
  180.           ((search-documentation-files term)
  181.            => (lambda (doc)
  182.                 (write-line "Documentation from file:")
  183.                 (write-line doc)))
  184.           (else
  185.            ;; no matches
  186.            (display "Did not find any object ")
  187.            (simple-format #t
  188.                           (if (symbol? term)
  189.                               "named `~A'\n"
  190.                               "matching regexp \"~A\"\n")
  191.                           term)))))
  192.  
  193. (define (help-usage)
  194.   (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
  195.        (help REGEXP) ditto for objects with names matching REGEXP (a string)
  196.        (help 'NAME) gives documentation for NAME, even if it is not an object
  197.        (help ,EXPR) gives documentation for object returned by EXPR
  198.        (help (my module)) gives module commentary for `(my module)'
  199.        (help) gives this text
  200.  
  201. `help' searches among bindings exported from loaded modules, while
  202. `apropos' searches among bindings visible from the \"current\" module.
  203.  
  204. Examples: (help help)
  205.           (help cons)
  206.           (help \"output-string\")
  207.  
  208. Other useful sources of helpful information:
  209.  
  210. (apropos STRING)
  211. (arity PROCEDURE)
  212. (name PROCEDURE-OR-MACRO)
  213. (source PROCEDURE-OR-MACRO)
  214.  
  215. Tools:
  216.  
  217. (backtrace)                ;show backtrace from last error
  218. (debug)                    ;enter the debugger
  219. (trace [PROCEDURE])            ;trace procedure (no arg => show)
  220. (untrace [PROCEDURE])            ;untrace (no arg => untrace all)
  221.  
  222. (OPTIONSET-options 'full)        ;display option information
  223. (OPTIONSET-enable 'OPTION)
  224. (OPTIONSET-disable 'OPTION)
  225. (OPTIONSET-set! OPTION VALUE)
  226.  
  227. where OPTIONSET is one of debug, read, eval, print
  228.  
  229. "))
  230.  
  231. ;;; {Apropos}
  232. ;;;
  233. ;;; Author: Roland Orre <orre@nada.kth.se>
  234. ;;;
  235.  
  236. (define (apropos rgx . options)
  237.   "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
  238.   (if (zero? (string-length rgx))
  239.       "Empty string not allowed"
  240.       (let* ((match (make-regexp rgx))
  241.          (uses (module-uses (current-module)))
  242.          (modules (cons (current-module)
  243.                 (if (and (not (null? uses))
  244.                      (eq? (module-name (car uses))
  245.                       'duplicates))
  246.                 (cdr uses)
  247.                 uses)))
  248.          (separator #\tab)
  249.          (shadow (member 'shadow options))
  250.          (value (member 'value options)))
  251.     (cond ((member 'full options)
  252.            (set! shadow #t)
  253.            (set! value #t)))
  254.     (for-each
  255.      (lambda (module)
  256.        (let* ((name (module-name module))
  257.           (obarray (module-obarray module)))
  258.          ;; XXX - should use hash-fold here
  259.          (hash-for-each
  260.           (lambda (symbol variable)
  261.         (cond ((regexp-exec match (symbol->string symbol))
  262.                (display name)
  263.                (display ": ")
  264.                (display symbol)
  265.                (cond ((variable-bound? variable)
  266.                   (let ((val (variable-ref variable)))
  267.                 (cond ((or (procedure? val) value)
  268.                        (display separator)
  269.                        (display val)))))
  270.                  (else
  271.                   (display separator)
  272.                   (display "(unbound)")))
  273.                (if (and shadow
  274.                 (not (eq? (module-ref module symbol)
  275.                       (module-ref (current-module) symbol))))
  276.                (display " shadowed"))
  277.                (newline))))
  278.           obarray)))
  279.      modules))))
  280.  
  281. (define (apropos-internal rgx)
  282.   "Return a list of accessible variable names."
  283.   (apropos-fold (lambda (module name var data)
  284.           (cons name data))
  285.         '()
  286.         rgx
  287.         (apropos-fold-accessible (current-module))))
  288.  
  289. (define (apropos-fold proc init rgx folder)
  290.   "Folds PROCEDURE over bindings matching third arg REGEXP.
  291.  
  292. Result is
  293.  
  294.   (PROCEDURE MODULE1 NAME1 VALUE1
  295.     (PROCEDURE MODULE2 NAME2 VALUE2
  296.       ...
  297.       (PROCEDURE MODULEn NAMEn VALUEn INIT)))
  298.  
  299. where INIT is the second arg to `apropos-fold'.
  300.  
  301. Fourth arg FOLDER is one of
  302.  
  303.   (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
  304.   apropos-fold-exported           ;fold over all exported bindings
  305.   apropos-fold-all           ;fold over all bindings"
  306.   (let ((match (make-regexp rgx))
  307.     (recorded (make-vector 61 '())))
  308.     (let ((fold-module
  309.        (lambda (module data)
  310.          (let* ((obarray-filter
  311.              (lambda (name val data)
  312.                (if (and (regexp-exec match (symbol->string name))
  313.                 (not (hashq-get-handle recorded name)))
  314.                (begin
  315.                  (hashq-set! recorded name #t)
  316.                  (proc module name val data))
  317.                data)))
  318.             (module-filter
  319.              (lambda (name var data)
  320.                (if (variable-bound? var)
  321.                (obarray-filter name (variable-ref var) data)
  322.                data))))
  323.            (cond (module (hash-fold module-filter
  324.                     data
  325.                     (module-obarray module)))
  326.              (else data))))))
  327.       (folder fold-module init))))
  328.  
  329. (define (make-fold-modules init-thunk traverse extract)
  330.   "Return procedure capable of traversing a forest of modules.
  331. The forest traversed is the image of the forest generated by root
  332. modules returned by INIT-THUNK and the generator TRAVERSE.
  333. It is an image under the mapping EXTRACT."
  334.   (lambda (fold-module init)
  335.     (let* ((table (make-hash-table 31))
  336.        (first? (lambda (obj)
  337.              (let* ((handle (hash-create-handle! table obj #t))
  338.                 (first? (cdr handle)))
  339.                (set-cdr! handle #f)
  340.                first?))))
  341.       (let rec ((data init)
  342.         (modules (init-thunk)))
  343.     (do ((modules modules (cdr modules))
  344.          (data data (if (first? (car modules))
  345.                 (rec (fold-module (extract (car modules)) data)
  346.                  (traverse (car modules)))
  347.                 data)))
  348.         ((null? modules) data))))))
  349.  
  350. (define (apropos-fold-accessible module)
  351.   (make-fold-modules (lambda () (list module))
  352.              module-uses
  353.              identity))
  354.  
  355. (define (root-modules)
  356.   (cons the-root-module
  357.     (submodules (nested-ref the-root-module '(app modules)))))
  358.  
  359. (define (submodules m)
  360.   (hash-fold (lambda (name var data)
  361.            (let ((obj (and (variable-bound? var) (variable-ref var))))
  362.          (if (and (module? obj)
  363.               (eq? (module-kind obj) 'directory))
  364.              (cons obj data)
  365.              data)))
  366.          '()
  367.          (module-obarray m)))
  368.  
  369. (define apropos-fold-exported
  370.   (make-fold-modules root-modules submodules module-public-interface))
  371.  
  372. (define apropos-fold-all
  373.   (make-fold-modules root-modules submodules identity))
  374.  
  375. (define (source obj)
  376.   (cond ((procedure? obj) (procedure-source obj))
  377.     ((macro? obj) (procedure-source (macro-transformer obj)))
  378.     (else #f)))
  379.  
  380. (define (arity obj)
  381.   (define (display-arg-list arg-list)
  382.     (display #\`)
  383.     (display (car arg-list))
  384.     (let loop ((ls (cdr arg-list)))
  385.       (cond ((null? ls)
  386.          (display #\'))
  387.         ((not (pair? ls))
  388.          (display "', the rest in `")
  389.          (display ls)
  390.          (display #\'))
  391.         (else
  392.          (if (pair? (cdr ls))
  393.          (display "', `")
  394.          (display "' and `"))
  395.          (display (car ls))
  396.          (loop (cdr ls))))))
  397.   (define (display-arg-list/summary arg-list type)
  398.     (let ((len (length arg-list)))
  399.       (display len)
  400.       (display " ")
  401.       (display type)
  402.       (if (> len 1)
  403.       (display " arguments: ")
  404.       (display " argument: "))
  405.       (display-arg-list arg-list)))
  406.   (cond
  407.    ((procedure-property obj 'arglist)
  408.     => (lambda (arglist)
  409.      (let ((required-args (car arglist))
  410.            (optional-args (cadr arglist))
  411.            (keyword-args (caddr arglist))
  412.            (allow-other-keys? (cadddr arglist))
  413.            (rest-arg (car (cddddr arglist)))
  414.            (need-punctuation #f))
  415.        (cond ((not (null? required-args))
  416.           (display-arg-list/summary required-args "required")
  417.           (set! need-punctuation #t)))
  418.        (cond ((not (null? optional-args))
  419.           (if need-punctuation (display ", "))
  420.           (display-arg-list/summary optional-args "optional")
  421.           (set! need-punctuation #t)))
  422.        (cond ((not (null? keyword-args))
  423.           (if need-punctuation (display ", "))
  424.           (display-arg-list/summary keyword-args "keyword")
  425.           (set! need-punctuation #t)))
  426.        (cond (allow-other-keys?
  427.           (if need-punctuation (display ", "))
  428.           (display "other keywords allowed")
  429.           (set! need-punctuation #t)))
  430.        (cond (rest-arg
  431.           (if need-punctuation (display ", "))
  432.           (display "the rest in `")
  433.           (display rest-arg)
  434.           (display "'"))))))
  435.    (else
  436.     (let ((arity (procedure-property obj 'arity)))
  437.       (display (car arity))
  438.       (cond ((caddr arity)
  439.          (display " or more"))
  440.         ((not (zero? (cadr arity)))
  441.          (display " required and ")
  442.          (display (cadr arity))
  443.          (display " optional")))
  444.       (if (and (not (caddr arity))
  445.            (= (car arity) 1)
  446.            (<= (cadr arity) 1))
  447.       (display " argument")
  448.       (display " arguments"))
  449.       (if (closure? obj)
  450.       (let ((formals (cadr (procedure-source obj))))
  451.         (cond
  452.          ((pair? formals)
  453.           (display ": ")
  454.           (display-arg-list formals))
  455.          (else
  456.           (display " in `")
  457.           (display formals)
  458.           (display #\'))))))))
  459.   (display ".\n"))
  460.  
  461. (define system-module
  462.   (procedure->syntax
  463.    (lambda (exp env)
  464.      (let* ((m (nested-ref the-root-module
  465.                (append '(app modules) (cadr exp)))))
  466.        (if (not m)
  467.        (error "Couldn't find any module named" (cadr exp)))
  468.        (let ((s (not (procedure-property (module-eval-closure m)
  469.                      'system-module))))
  470.      (set-system-module! m s)
  471.      (string-append "Module " (symbol->string (module-name m))
  472.             " is now a " (if s "system" "user") " module."))))))
  473.  
  474. ;;; session.scm ends here
  475.